Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / More classes / MW documents / MW3⁄4Mod.txt < prev next >

Wrap

Text File | 1990-08-08 | 32.4 KB | 1,454 lines | [TEXT/MSET]

\ Word 3 and 4 documents. 0 value BUF_START 0 value STLS \ Holds copy of styles byte of current format 0 value OPTIONS \ Holds copy of options byte 0 value DOING_PARAS? \ The following words handle the "change information" that is present if \ the document was saved using "Fast save". This is fairly complicated, \ so we hope we've got it right. If we don't recognize something, we set \ MYSTERY? true and put the code we didn't recognize into UNPROCESSED_CODE, \ so the application can warn the user that there may be problems. These \ problems may be insignificant, which is why we don't give a hard error. 0 value #CHANGES 0 value OPCODE \ Holds op code for style etc. override 0 value OVERRIDE_MARKER 0 value NEW_CHANGE_BLK? 0 value FMT_STRT 0 value CHG-BLK? 0 value CHGD-BLK? \ True if previous offset was in a new chg blk 0 value OV_BLK# false value OV_ON? create STYLES here hex 80 c, \ bold 40 c, \ italic 20 c, \ strikethru 10 c, \ outline 08 c, \ shadow 04 c, \ small caps 02 c, \ all caps 01 c, \ hidden decimal here swap - constant STYLES_LEN \ ============== Setting up ================ : LOCATE_NEW_CHANGE { offs -- } reset: changes BEGIN len: changes 0EXIT offs ^1st: changes @ < ?EXIT 14 skip: changes AGAIN ; local FIX_OVERRIDE { \ this_dst -- } : SETUP_OFFSETS true -> ov_on? \ Forces generation of a fmt_ov_run entry to \ turn overrides off at the start tmp dup copyto: src copyto: dst len: tmp 2/ 2/ 1- 3 / -> #changes #changes 1+ 4* skip: src 4 nxtn: dst -> this_dst #changes 0 ?DO pause 2 skip: src 4 nxtn: src hdr_len - \ source offset - save dup locate_new_change 2 nxtn: src -> override_marker ( this_dst ) fix_override \ Note: uses PAD pad ! \ source offset to PAD 4 nxtn: dst dup this_dst - pad 4+ ! \ length this_dst pad 8 + ! \ dest offset -> this_dst override_marker pad 12 + w! \ override marker pad 14 insert: changes \ Move new entry in from PAD LOOP ; : SU_STYL_OV nxtc: tmp dup $ 80 <> and \ 0 or $ 80 mean off, anything else means 0<> negate \ on ... I hope ... opcode $ 1E - ^1st: fmt_ov_str + c! ; : SU_FONT_OV 2 nxtn: tmp ^1st: fmt_ov_str 10 + w! ; : SU_SIZ_OV nxtc: tmp 2/ ^1st: fmt_ov_str 9 + c! ; : SU_UND_OV nxtc: tmp 2* ^1st: fmt_ov_str 8 + c! ; : SU_VD_OV nxtc: tmp dup $ 80 = IF drop 0 THEN ^1st: fmt_ov_str 12 + c! ; : SU_HD_OV nxtc: tmp $ 40 - 2* 2* ^1st: fmt_ov_str 13 + c! ; : SU_PARA_OV1 1 skip: tmp ; \ opcode 5 = \ IF nxtc: tmp ^1st: para_ov_str w! \ ELSE 1 skip: tmp \ We're not handling these others \ THEN ; : SU_PARA_OV2 2 skip: tmp ; \ 2 nxtn: tmp \ opcode dup $ 13 >= - $ E - 2* ^1st: para_ov_str + w! ; : SU_STYL#_OV nxtc: tmp ^1st: para_ov_str ( 2+ ) w! ; : SU_OUTL_OV nxtc: tmp 2+ \ outlining level no. 1 max 9 min \ just in case negate $ FF and ^1st: para_ov_str ( 2+ ) w! ; : SU_SECT_OV this_dst +L: sect_ov_str nxtc: tmp +W: sect_ov_str ; : SETUP_1_OVERRIDE nxtc: tmp dup -> opcode CASE[ $ 1E $ 25 RANGE]=> su_styl_ov [ $ 05 $ 0B RANGE]=> su_para_ov1 [ $ 10 $ 15 RANGE]=> su_para_ov2 [ $ 02 ]=> su_styl#_ov [ $ 04 ]=> su_outl_ov [ $ 0F ]=> ( tabs - we're ignoring them ) nxtc: tmp ( length ) skip: tmp [ $ 26 ]=> su_font_ov [ $ 27 ], [ $ 45 ]=> su_und_ov \ The 45 can come in W4 docs [ $ 28 ]=> su_siz_ov [ 0 ]=> su_VD_ov [ $ 29 ]=> su_HD_ov [ $ 41 ]=> su_sect_ov [ $ 1D ]=> ( pass - do nothing) DEFAULT=> \ This means an opcode we don't know anything about. \ So we set MYSTERY? and skip to the end of the field. -> unprocessed_code true -> mystery? lim: tmp >pos: tmp ]CASE ; : SETUP_OVERRIDES pause 1 ++> ov_blk# end: fmt_ov_str pos: fmt_ov_str pad infoSize: fmt_run 2dup 128 fill add: fmt_ov_str \ set all fields to "leave" initially >pos: fmt_ov_str end: para_ov_str pos: para_ov_str pad infoSize: para_run 2dup bounds DO $ 8000 i w! 2 +LOOP add: para_ov_str >pos: para_ov_str BEGIN len: tmp 1 > WHILE setup_1_override REPEAT ; : TURN_OV_OFF \ ( dest -- ) false -> ov_on? pad ! pad 4+ infoSize: fmt_run 128 fill pad itemSize: fmt_run add: fmt_ov_run ; :loc FIX_OVERRIDE override_marker ov_on? or 0EXIT \ Out if we don't need an \ override entry here override_marker NIF this_dst turn_ov_off EXIT THEN true -> ov_on? override_marker $ 8000 and NIF \ It's immediate - create new ov str entries and make indirect. save: tmp src copyto: tmp -2 skip: tmp 2 >len: tmp setup_overrides \ Actually, there's only 1 restore: tmp ov_blk# 1- $ 8000 or -> override_marker THEN \ Now put new entry into FMT_OV_RUN this_dst +L: fmt_ov_run infoSize: fmt_run dup override_marker $ 7FFF and * >pos: fmt_ov_str >len: fmt_ov_str fmt_ov_str $add: fmt_ov_run ;loc : SETUP_CHANGE \ ( code -- ) CASE[ 1 ]=> setup_overrides [ 2 ]=> setup_offsets DEFAULT=> -> unprocessed_code true -> mystery? ]CASE lim: tmp >pos: tmp ; \ ======= Applying the changes ======= : EXTEND_TEXT \ Yes, this can happen, if changes insert stuff! \ pos: text real_text_len <= \ IF \ Extending at or before the end. Adjust real_text_len \ len: theFile len: text - ++> real_text_len \ THEN pos: text dup len: theFile + \ Desired length setsize: text >pos: text ; : CHANGE_TEXT reset: text reset: changes 0 -> text&hf_len #changes 0 ?DO nxtL: changes >pos: theFile nxtL: changes >len: theFile nxtL: changes >pos: text len: theFile len: text > IF extend_text THEN theFile $ovwr: text pos: text text&hf_len max -> text&hf_len 2 skip: changes ( we don't use the override marker here ) LOOP real_text_len text&hf_len max setsize: text ; : FIND_OV_POSN override_marker ?dup 0EXIT $ 7FFF and infoSize: para_run * >pos: para_ov_str ; : FIND_PLACE { offs -- } BEGIN len: changes 0EXIT offs ^1st: changes @ ^1st: changes 4+ @ + doing_paras? IF <= ELSE < THEN ?EXIT 14 skip: changes AGAIN ; : DIFFERENT_CHANGE_BLK { offs -- } offs find_place len: changes IF ^1st: changes 12 + w@ -> override_marker find_ov_posn ELSE 0 -> override_marker THEN ; : CHANGE_OFFSET { offs -- offs' } \ Returns -1 if offs is outside limits. chg-blk? -> chgd-blk? fast? NIF offs EXIT THEN len: changes NIF -1 EXIT THEN offs ^1st: changes @ ^1st: changes 4+ @ + doing_paras? IF > ELSE >= THEN dup -> chg-blk? IF offs different_change_blk len: changes NIF -1 EXIT THEN THEN offs ^1st: changes @ - 0 max \ Coerce font change rightward \ after a deletion ^1st: changes 8 + @ + ; \ Return transformed offset : OFF_FMTS \ Inserts entries into fmt_run to turn formats \ off at the end of change blocks. fast? 0EXIT reset: changes BEGIN len: changes NIF reset: fmt_run reset: changes EXIT THEN 4 skip: changes nxtL: changes nxtL: changes + dup true find_posn: fmt_run new_item: fmt_run styles_len 1+ skip: fmt_run 12 >nxtc: fmt_run dflt_font# >nxtw: fmt_run 2 skip: changes AGAIN ; : ?DO_PARA_OVERRIDE \ Note: para_run POS is at the start of the \ styles field. override_marker 0EXIT ^1st: para_ov_str w@ dup $ 8000 <> IF ^1st: para_run w! ELSE drop THEN ; \ pos: para_run \ infoSize: para_run 0 DO \ ^1st: para_ov_str i + w@ dup $ 8000 <> \ IF >nxtw: para_run ELSE drop 2 skip: para_run THEN \ 2 +LOOP \ >pos: para_run ; \ ======= Miscellaneous useful words ======= : SETUP_BLKS \ ( -- #blks ) theFile copyto: dst len: dst 4- 6 / ( # blks ) dup 1+ 4* skip: dst reset: changes false -> chg-blk? false -> chgd-blk? ; : NEXT_OFFS { \ offs -- offs } save_offs -> offs unmpd_new -> unmpd_old nxtl: buf hdr_len - dup -> unmpd_new change_offset -> save_offs doing_paras? NIF offs EXIT THEN \ For paras, we have to make sure that the incoming para offsets correspond \ to the RET chars in the text, since changes might have deleted or inserted \ extra RETs. We do this here. What this amounts to is that we have to find \ the RET which begins the para immediately before where SAVE_OFFS points. \ We return the offs of this para (i.e. the offs of RET plus 1). start: text save_offs 1 max >lim: text -1 more: text RET <chsearch: text pos: text swap - ; \ If RET found, skip it : NEXT_ITEM? \ ( -- offs T | F ) next_offs chgd-blk? IF dup true doing_paras? IF find_posn: para_run ELSE find_posn: fmt_run THEN THEN ( offs ) dup 0>= dup NIF nip 1 skip: buf_offsets THEN ; \ ======== Merging formats ======== \ This isn't fun!! : MERGE1 { offs -- } offs +L: fmt_run pos: src ( save ) 4 skip: src infoSize: fmt_run >len: src pos: fmt_run src $add: fmt_run >pos: fmt_run >pos: src nolim: src 4 skip: fmt_ov_run infoSize: fmt_run 0 DO ^1st: fmt_ov_run i + c@ dup 128 <> IF >nxtc: fmt_run ELSE drop 1 skip: fmt_run THEN LOOP ^1st: fmt_ov_run 10 + c@ 128 <> IF ( kludge to make sure font# 128 works ) ^1st: fmt_ov_run 11 + c@ ^1st: fmt_run 3 - c! THEN -4 skip: fmt_ov_run ; 0 value PREV \ Holds offset in SRC of last entry read \ -- this is the one currently in effect : DO_LIMIT { limit -- } \ Generates new fmt_run entry for override \ change at the limit skip_item: fmt_ov_run prev 0< IF \ No SRC entry valid yet. Just copy ov entry over itemSize: fmt_run >len: fmt_ov_run fmt_ov_run $add: fmt_run nolim: fmt_ov_run ELSE prev swappos: src limit merge1 <skip_item: fmt_ov_run >pos: src THEN ; : MERGE_TO_LIMIT { limit \ src-offs done? do-lim? -- } false -> done? false -> do-lim? BEGIN len: src IF ^1st: src @ -> src-offs src-offs limit 2dup > -> do-lim? >= -> done? ELSE \ No formats left. We may, however, have to generate a \ fmt_run entry for the limit. We only need to do this \ if it is a "real" (not a dummy) limit. limit big# <> -> do-lim? true -> done? THEN do-lim? IF limit do_limit EXIT THEN done? ?EXIT src-offs merge1 pos: src -> prev skip_item: src AGAIN ; : (MERGE_FMTS) -1 -> prev ( means not valid yet ) BEGIN pause len: fmt_ov_run NIF ( no more overrides left - copy rest of src over ) src $add: fmt_run EXIT THEN len: src NIF <skip_item: src BEGIN len: fmt_ov_run 0EXIT ^1st: fmt_ov_run @ merge1 skip_item: fmt_ov_run AGAIN THEN len: fmt_ov_run itemSize: fmt_ov_run > IF ^1st: fmt_ov_run itemSize: fmt_ov_run + @ ELSE big# THEN merge_to_limit skip_item: fmt_ov_run AGAIN ; : MERGE_FMTS fast? 0EXIT reset: fmt_ov_run len: fmt_ov_run 0EXIT \ Out if nothing to merge fmt_run copyto: src reset: src new: fmt_run (merge_fmts) \ Do it release: src ; \ ======= Style sheet operations ======= \ The string of style names has the level names first, in reverse order, \ then any synonym(s) for "Normal" (empty if none), then the ordinary \ styles in forward order. scon NORM_STYLE "Normal" hex table DFLT_FONT 05001800 , dflt_font# c, 18 c, \ Default: Geneva 12 end_table table DFLT_PARA \ 07000000 , 0 , 03000000 , end_table decimal : SKIP1NAME \ is1st# 255 of> style_names 1st: style_names $ FF = IF 1 skip: style_names ELSE count: style_names step: style_names THEN ; : COUNT_STYLES reset: style_names 0 -> #styles BEGIN len: style_names WHILE skip1name 1 ++> #styles REPEAT ; : GET_STYLE_NAME { n \ cnt -- addr len } \ Exported. n NIF norm_style EXIT THEN reset: style_names #levels negate -> cnt BEGIN len: style_names NIF 0 0 EXIT THEN cnt n = IF \ is1st# 255 of> style_names IF 0 0 EXIT THEN 1st: style_names $ FF = IF 0 0 EXIT THEN count: style_names get: style_names EXIT THEN skip1name 1 ++> cnt AGAIN ; : GET_STYLE# { addr len \ n -- n } \ Exported. \ Maybe we should handle synonyms at some stage, if \ anyone wants it. addr len norm_style s= IF 0 EXIT THEN reset: style_names #levels negate -> n BEGIN len: style_names NIF \ Put new style name in len +: style_names addr len add: style_names 1 ++> #styles n EXIT THEN \ is1st# 255 of> style_names 1st: style_names $ FF = IF 1 skip: style_names ELSE count: style_names get: style_names addr len s= IF n EXIT THEN step: style_names THEN 1 ++> n AGAIN ; : DUMMY_LEVEL_INFO reset: style_names pad #levels 2dup -1 fill add: src #levels 0 ?DO skip1name LOOP ; : SS_FORMATS dummy_level_info \ Dummy formats dflt_font add: src \ Default format for Normal style skip1name \ Skip Normal name #styles #levels - 1 ?DO \ Put in dummy formats \ is1st# 255 of> style_names 1st: style_names $ FF = IF $ FF +c: src 1 skip: style_names ELSE 0 +c: src count: style_names step: style_names THEN LOOP reset: src len: src 2+ 2 +n: dst src $add: dst ; : SS_PARAS clear: src dummy_level_info #styles #levels - 0 ?DO \ is1st# 255 of> style_names 1st: style_names $ FF = IF $ FF +c: src 1 skip: style_names ELSE dflt_para add: src i ^1st: src 3 - c! count: style_names step: style_names THEN LOOP reset: src len: src 2+ 2 +n: dst src $add: dst ; : SETUP_STYLE_SHEET new: src new: dst size: style_names IF count_styles ELSE \ There must be at least a "normal" style, or Word will \ crash! So we'll put one in. 0 +c: style_names 1 -> #styles THEN reset: style_names #levels +W: dst len: style_names 2+ +W: dst style_names $add: dst ss_formats ss_paras #styles 2 +N: dst pad #levels 2* 2dup erase add: dst $ 00DE 2 +n: dst #styles #levels - 1- 0 ?DO 0 2 +n: dst LOOP reset: dst release: src ; : NEED_LEVEL { lev# \ n -- } \ Exported. Ensures that the number of levels we \ have is at least lev#. lev# #levels - -> n n 0<= ?EXIT start: style_names pad n 2dup -1 fill insert: style_names lev# -> #levels ; \ ============================== :class SD super( object ) var START int LENGTH :m GET: get: start get: length ;m :m PUT: put: length put: start ;m :m USE: get: self swap hdr_len - >pos: theFile >len: theFile ;m ;class table FOR_STRC hex 2 w, 3 w, 4 w, 5 w, 10 w, 14 w, 1D w, C9 w, F1 w, F3 w, end_table decimal table DFLT_P 0 w, 0 c, end_table :class MW3DOC super( object ) int MARKER 8 bytes xx1 int FAST_SAVE? int xx2 var TX_END_OFFS 12 bytes xx3 sd STYLES_STR1 sd STYLES_STR2 sd FTN_MARKER_STR sd FTN_OFFSET_STR sd SECTOFFS_STR sd Str4 sd Str5 sd Str6 sd HFOFFS_STR sd FMT_BLK_STR sd PARA_BLK_STR sd Str8 sd StrC sd Str9 sd CHANGE_STR var TEXT_START var TEXT_LENGTH var FOOTNOTE_LEN var HF_LEN 36 bytes xx6 int PAPER_HT int PAPER_WDTH int T_MARGIN int L_MARGIN int B_MARGIN int R_MARGIN var MAGIC3 int PAGE_OPTIONS int MAGIC5 int MAGIC6 int MAGIC7 int HOW_PRINT? 58 bytes EMPTY :m CLR_BUF: reset: buf all: buf erase ;m :m SET_BUF: \ ( blk# -- ) theFile copyto: buf 2- 7 << dup >pos: buf -> buf_start 128 >len: buf buf copyto: buf_offsets buf copyto: buf_tmp ;m :m BUF_OUT: all: buf write: theFcb OK? ;m :m SETUP_CHANGES: { \ this_dst -- } clear: changes clear: fmt_ov_str 0 -> override_marker fast? 0EXIT 0 -> ov_blk# use: change_str theFile copyto: tmp BEGIN len: tmp 0> ( a bug could make it negative!!! ) WHILE nxtc: tmp ( opcode ) 2 nxtn: tmp >len: tmp setup_change lim: theFile >lim: tmp REPEAT reset: changes reset: fmt_ov_str ^1st: changes 12 + w@ -> override_marker ( initial value ) find_ov_posn ;m :m TEXT_IN: pause text&HF_len setsize: text fast? IF change_text ELSE reset: text get: text_start hdr_len - >pos: theFile nolim: theFile theFile $ovwr: text reset: text THEN text_only? 0EXIT real_text_len setsize: text reset: text ;m :m GET_FONT: \ ( -- fnt# ) options $ 10 and NIF dflt_font# ELSE fmt 3+ 2b@ THEN >nxtw: fmt_run ;m :m GET_FONTSIZE: \ ( -- n ) options 8 and NIF 12 ELSE fmt 5 + c@ 2/ THEN >nxtc: fmt_run ;m :m GET_FIELD: \ ( offs -- ) fmt + c@ ( optional field ) >nxtc: fmt_run ;m :m GET_FMT: { offs -- } \ Converts the current format to our internal coding \ and inserts it in FMT_RUN. fmt 1+ c@ -> stls fmt 2+ c@ dup -> options $ 40 and IF offs spec_in EXIT THEN offs new_item: fmt_run pos: fmt_run -> fmt_strt styles styles_len bounds DO i c@ ( mask ) stls and 0<> ( 1 set, 0 clear ) >nxtc: fmt_run LOOP 8 get_field: self ( underline options ) get_fontsize: self get_font: self 6 get_field: self ( vert displ ) 7 get_field: self ( horiz displ ) ;m :m (FMT_IN): { \ offs -- } next_item? 0EXIT -> offs fmt fmt_len erase nxtc: buf_offsets ?dup IF buf_start + >pos: buf_tmp ^1st: buf_tmp fmt over c@ 1+ cmove THEN offs get_fmt: self ;m :m (FMT_BLK_IN): \ ( cnt -- ) 2 nxtn: fmt_blk#s set_buf: self NIF next_offs drop ELSE 4 skip: buf THEN last: buf ( # formats ) dup 1+ 4* skip: buf_offsets 0 ?DO (fmt_in): self LOOP ;m :m FMTS_IN: false -> doing_paras? use: fmt_blk_str setup_blks -> #fmt_blks dst copyto: fmt_blk#s off_fmts #fmt_blks 0 DO pause i (fmt_blk_in): self LOOP merge_fmts trim_fmt_run ;m :m GET_PARA: { \ addr code -- } ^1st: para_run -> addr nxtc: buf_tmp addr w! ;m \ style # :m (PARA_IN): next_item? 0EXIT ( offs ) new_item: para_run nxtc: buf_offsets ?dup IF buf_start + >pos: buf_tmp count: buf_tmp get_para: self THEN ?do_para_override ?keep_para ;m :m (PARA_BLK_IN): \ ( cnt -- ) 2 nxtn: para_blk#s set_buf: self NIF next_offs drop ELSE 4 skip: buf THEN last: buf ( # paras ) dup 1+ 4* skip: buf_offsets 0 DO (para_in): self LOOP ;m :m PARAS_IN: true -> doing_paras? use: para_blk_str setup_blks -> #para_blks dst copyto: para_blk#s #para_blks 0 DO pause i (para_blk_in): self LOOP ;m :m STYLES_IN: \ Note: we ignore input style specifications, and just \ hang on to the names. pause use: styles_str2 2 nxtn: theFile -> #levels 2 nxtn: theFile 2- >len: theFile theFile ->: style_names ;m :m HFs_IN: use: sectoffs_str theFile ->: sect_offsets use: HFoffs_str mark_HFs ;m :m FTNOTES_IN: \ Footnotes in. Sorry for funny name - we had \ a hash collision. ftn_len 0EXIT \ Out if no footnotes use: ftn_marker_str theFile ->: ftn_markers use: ftn_offset_str theFile ->: ftn_offsets mark_ftn ;m :m SETUP_INPUT: pause new: theFile new: changes new: fmt_ov_str new: fmt_ov_run new: para_ov_str new: sect_offsets new: sect_ov_str new: ftn_markers new: ftn_offsets false -> mystery? 0 -> #insrtd 0 -> save_offs ^base 2+ hdr_len 2- read: theFcb OK? get: fast_save? -> fast? get: text_length -> real_text_len get: tx_end_offs hdr_len - -> text&HF_len get: page_options $ 8000 and 0<> -> facing_pages? text&HF_len ++> mem_needed get: footnote_len -> ftn_len text_only? ?EXIT size: theFcb hdr_len - text&HF_len - 3 * 0 max \ Guesstimate for size of fmt_run etc. ++> mem_needed ;m :m INPUT_FILE: pause theFcb size: theFcb hdr_len - readn: theFile ;m :m FIXIT: setup_changes: self text_in: self text_only? NIF fmts_in: self paras_in: self styles_in: self ftnotes_in: self HFs_in: self THEN ;m :m WINDUP_INPUT: release: theFile release: changes release: fmt_ov_str release: fmt_ov_run release: para_ov_str release: sect_offsets release: sect_ov_str release: ftn_markers release: ftn_offsets ;m \ ========== Output =========== :m SETUP_OUTPUT: ^base hdr_len 2dup erase write: theFcb OK? ( dummy header ) new: buf 128 setsize: buf clr_buf: self new: buf_offsets new: fmt_blk#s new: para_blk#s new: para_tmp new: hf_offsets new: sect_offsets new: ftn_markers new: ftn_offsets 0 -> #fmt_blks 0 -> #para_blks false -> GHF? \ Now we set the default format - leave zero so style sheet \ determines everything. fmt fmt_len erase ;m :m (NEW_BLK): clr_buf: self -1 more: buf clear: buf_offsets save_offs hdr_len + >nxtl: buf 0 -> #entries ;m :m (WRITE_BLK): all: buf_offsets >nxt$: buf clear: buf_offsets #entries all: buf + 1- c! buf_out: self (new_blk): self ;m :m WRITE_BLK: pause all: buf drop @ +L: blk#s (write_blk): self 1 ++> #blks ;m :m MATCH?: { addr len -- b } true -> case? buf copyto: tmp step: tmp false len 0EXIT BEGIN len: tmp 1 <= ?EXIT count: tmp addr len compare: tmp NIF ( match occurred ) drop true pos: tmp 1- +c: buf_offsets EXIT THEN step: tmp AGAIN ;m :m STR_OUT: { offs addr len \ matched? bo_len -- } false -> matched? all: buf_offsets -> bo_len drop len: buf bo_len - 5 < IF write_blk: self ELSE addr len match?: self dup -> matched? NIF len: buf bo_len - len 6 + < IF write_blk: self THEN THEN THEN 1 ++> #entries offs -> save_offs offs hdr_len + >nxtl: buf matched? ?EXIT len IF len 1+ negate more: buf lim: buf +c: buf_offsets buf copyto: tmp step: tmp len >nxtc: tmp addr len >nxt$: tmp ELSE 0 +c: buf_offsets THEN ;m :m SET_FIELD: { n dflt mask offs -- } n 128 = ?EXIT \ No action if "leave" specified mask fmt 2+ n dflt = IF creset 0 ELSE cset n mask 8 = IF 2* THEN \ must double font size THEN fmt offs + c! ;m :m SET_FONT: { \ font# -- } nxtw: fmt_run -> font# font# $ 8000 and ?EXIT \ Out if "leave" $ 10 fmt 2+ font# dflt_font# = IF creset 0 ELSE cset font# THEN fmt 3 + 2b! ;m :m SET_FMT_LEN: 8 fmt 1+ fmt 8 + DO i c@ IF LEAVE ELSE 1- THEN -1 +LOOP fmt c! ;m :m CHK_SPEC: \ ( -- b ) Returns FALSE if this format is not \ a special, so SET_FMT: will handle it. BEGIN ^1st: fmt_run 10 + w@ \ Font # or graphics flag $ FFFF = 0dup 0EXIT \ Out if font # handle_spec str_out: self skip_info: fmt_run len: fmt_run 0= ?dup ?EXIT ^1st: fmt_run @ save_offs <> ?dup ?EXIT \ Next format has same offset. So we loop to process it now. 4 skip: fmt_run AGAIN ;m :m SET_FMT: chk_spec: self ?EXIT \ Out if "format" was a special styles styles_len bounds DO i c@ ( mask ) nxtc: fmt_run ( 0 = clear, 128 = leave, anything else = set ) dup 128 = IF 2drop ELSE IF ( set ) fmt 1+ cset ELSE ( clear ) fmt 1+ creset THEN THEN LOOP \ Parms for set_field: n dflt mask offs nxtc: fmt_run ( undl ) 0 $ 04 8 set_field: self nxtc: fmt_run ( size ) 0 $ 08 5 set_field: self set_font: self nxtc: fmt_run ( v displ ) 0 $ 02 6 set_field: self nxtc: fmt_run ( h displ ) 0 $ 01 7 set_field: self set_fmt_len: self ;m :m (FMT_OUT): \ ( offs -- ) fmt count str_out: self ;m :m FMT_OUT: \ ( offs -- ) \ Note: we don't o/p default format if fmt_run starts with a zero offset. ?dup IF (fmt_out): self THEN set_fmt: self ;m :m SET_PARA: 3 setsize: para_tmp reset: para_tmp \ nxtw: para_run ( justification - save ) nxtw: para_run ( style # ) >nxtc: para_tmp 0 pad ! pad 2 >nxt$: para_tmp \ ( justif. ) ?dup IF 5 +c: para_tmp +c: para_tmp THEN \ $ 12 $ 10 DO \ nxtw: para_run \ ?dup IF i +c: para_tmp 2 +n: para_tmp THEN \ LOOP \ $ 16 $ 13 DO \ nxtw: para_run \ ?dup IF i +c: para_tmp 2 +n: para_tmp THEN \ LOOP all: para_tmp dflt_p s= 0EXIT ( It's a default para ) clear: para_tmp ;m :m PARA_OUT: { offs -- } offs para_offs > IF set_para: self offs next_para THEN offs all: para_tmp str_out: self ;m :m TEXT_OUT: pause reset: text len: text -> total_text_len hdr_len moveto: theFcb OK? get: text write: theFcb OK? total_text_len hdr_len + -> buf_start \ Now pad out written text to 128-byte multiple len: text 127 and ?dup IF 128 swap - dup ++> buf_start pad swap write: theFcb OK? THEN ;m :m FMTS_OUT: fmt_blk#s copyto: blk#s mark_original: blk#s \ Safe - see end of defn 0 -> #blks 0 -> save_offs (new_blk): self reset: fmt_run BEGIN len: fmt_run WHILE nxtl: fmt_run fmt_out: self REPEAT \ real_text_len (fmt_out): self \ ************** GHF? IF GHF_formats_out THEN write_blk: self save_offs hdr_len + +L: blk#s blk#s copyto: fmt_blk#s mark_original: fmt_blk#s \ See, it was OK, wasn't it? #blks -> #fmt_blks ;m :m PARAS_OUT: para_blk#s copyto: blk#s mark_original: blk#s reset: text reset: para_run clear: para_tmp ( 0 +w: para_tmp 0 +c: para_tmp ) 0 -> #blks 0 -> save_offs (new_blk): self 0 next_para clear: utTbl RET selchar: utTbl SECT selchar: utTbl BEGIN utTbl scan: text WHILE step: text 1 skip: text text&hf_len >lim: text pos: text para_out: self REPEAT write_blk: self save_offs hdr_len + +L: blk#s blk#s copyto: para_blk#s mark_original: para_blk#s #blks -> #para_blks ;m :m HDR_OUT: pause $ FE34 put: marker text&hf_len hdr_len + put: tx_end_offs text&hf_len real_text_len - ftn_len - 2- 0 max put: hf_len hdr_len put: text_start real_text_len put: text_length ftn_len put: footnote_len $ 3DE0 put: paper_ht $ 2FD0 put: paper_wdth $ 5A0 dup put: t_margin dup put: l_margin dup put: b_margin put: r_margin $ 2d0 put: magic3 facing_pages? 15 << $ 400 or put: page_options 1 put: magic5 1 put: magic6 $ A000 put: how_print? ( tall adjusted ) 0 moveto: theFcb OK? ^base hdr_len write: theFcb OK? ;m :m FIX_FMT_BLKS: blk# #fmt_blks 0 DO dup +w: fmt_blk#s 1+ LOOP -> blk# reset: fmt_blk#s ;m :m FIX_PARA_BLKS: blk# #para_blks 0 DO dup +w: para_blk#s 1+ LOOP -> blk# reset: para_blk#s ;m :m CTRL_OUT: { addr len -- addr' len } pos: buf buf_start + len \ Return result addr len add: buf ;m :m $CTRL_OUT: { str -- addr' len' } lock: str all: str ctrl_out: self unlock: str ;m :m NULL_CTRL: pos: buf buf_start + 0 ;m :m EXTRAS_OUT: pause buf_start 7 >> -> blk# fix_fmt_blks: self fix_para_blks: self clear: buf blk# 7 << -> buf_start setup_style_sheet ( in dst ) dst $ctrl_out: self release: dst 2dup put: styles_str1 put: styles_str2 ftn_markers $ctrl_out: self put: ftn_marker_str ftn_offsets $ctrl_out: self put: ftn_offset_str sect_offsets $ctrl_out: self put: sectOffs_str null_ctrl: self 2dup put: str4 2dup put: str5 put: str6 hf_offsets $ctrl_out: self put: HFOffs_str null_ctrl: self put: str8 fmt_blk#s $ctrl_out: self put: fmt_blk_str para_blk#s $ctrl_out: self put: para_blk_str for_strC ctrl_out: self put: strC null_ctrl: self 2dup put: str9 put: change_str reset: buf len: buf buf_start + $ 1FF + $ FFFFFE00 and buf_start - setsize: buf all: buf write: theFcb OK? ;m :m SEND: \ ( fcb -- ) -> theFcb setup_output: self update_HFs fixup_ftn fixup_HFs mark_sp text_out: self fmts_out: self paras_out: self extras_out: self hdr_out: self release: buf release: buf_offsets release: fmt_blk#s release: para_blk#s release: para_tmp release: hf_offsets release: sect_offsets ;m release: ftn_markers release: ftn_offsets ;class \ Microsoft Word 4.0 documents table DFLT_P 0 w, 0 w, end_table :class MW4DOC super( object ) int MARKER int MAGIC1 6 bytes xx0 int FAST_SAVE? int MAGIC2 6 bytes xx1 var TEXT_START var TX_END_OFFS 8 bytes xx2 var TEXT_LENGTH var FOOTNOTE_LEN var HF_LEN 16 bytes xx3 sd STYLES_STR1 sd STYLES_STR2 sd FTN_MARKER_STR sd FTN_OFFSET_STR sd SECTOFFS_STR sd StrA sd Str5 sd Str6 sd HFOFFS_STR sd FMT_BLK_STR sd PARA_BLK_STR sd Str8 sd StrC sd StrD sd Str10 sd PRINT_STR1 sd PRINT_STR2 sd Str11 sd CHANGE_STR sd Str13 int MAGIC5 int MAGIC6 68 bytes EMPTY :m CLR_BUF: reset: buf all: buf erase ;m :m SET_BUF: \ ( blk# -- ) theFile copyto: buf \ 2- 9 \ 4 << hdr_len - \ 4 dup >pos: buf -> buf_start 512 \ 4 >len: buf buf copyto: buf_offsets buf copyto: buf_tmp ;m :m BUF_OUT: all: buf write: theFcb OK? ;m :m SETUP_CHANGES: { \ this_dst -- } clear: changes clear: fmt_ov_str 0 -> override_marker fast? 0EXIT 0 -> ov_blk# use: change_str theFile copyto: tmp BEGIN len: tmp 0> ( a bug could make it negative!!! ) WHILE nxtc: tmp ( opcode ) 2 nxtn: tmp >len: tmp setup_change lim: theFile >lim: tmp REPEAT reset: changes reset: fmt_ov_str ^1st: changes 12 + w@ -> override_marker ( initial value ) find_ov_posn ;m :m TEXT_IN: pause text&HF_len setsize: text fast? IF change_text ELSE reset: text get: text_start hdr_len - >pos: theFile nolim: theFile theFile $ovwr: text reset: text THEN text_only? 0EXIT real_text_len setsize: text reset: text ;m :m GET_FONT: \ ( -- fnt# ) options $ 10 and NIF dflt_font# ELSE fmt 3+ 2b@ THEN >nxtw: fmt_run ;m :m GET_FONTSIZE: \ ( -- n ) options 8 and NIF 12 ELSE fmt 5 + c@ 2/ THEN >nxtc: fmt_run ;m :m GET_FIELD: \ ( offs -- ) fmt + c@ ( optional field ) >nxtc: fmt_run ;m :m GET_FMT: { offs -- } \ Converts the current format to our internal coding \ and inserts it in FMT_RUN. fmt 1+ c@ -> stls fmt 2+ c@ dup -> options $ 40 and IF offs spec_in EXIT THEN offs new_item: fmt_run pos: fmt_run -> fmt_strt styles styles_len bounds DO i c@ ( mask ) stls and 0<> ( 1 set, 0 clear ) >nxtc: fmt_run LOOP 8 get_field: self ( underline options ) get_fontsize: self get_font: self 6 get_field: self ( vert displ ) 7 get_field: self ( horiz displ ) ;m :m (FMT_IN): { \ offs -- } next_item? 0EXIT -> offs fmt fmt_len erase nxtc: buf_offsets ?dup IF 2* \ 4 buf_start + >pos: buf_tmp ^1st: buf_tmp fmt over c@ 1+ cmove THEN offs get_fmt: self ;m :m (FMT_BLK_IN): \ ( cnt -- ) 2 nxtn: fmt_blk#s set_buf: self NIF next_offs drop ELSE 4 skip: buf THEN last: buf ( # formats ) dup 1+ 4* skip: buf_offsets 0 ?DO (fmt_in): self LOOP ;m :m FMTS_IN: false -> doing_paras? use: fmt_blk_str setup_blks -> #fmt_blks dst copyto: fmt_blk#s off_fmts #fmt_blks 0 DO pause i (fmt_blk_in): self LOOP merge_fmts trim_fmt_run ;m :m GET_PARA: { \ addr code -- } ^1st: para_run -> addr nxtc: buf_tmp addr w! ;m \ style # \ We now ignore all other para info. :m (PARA_IN): next_item? 0EXIT ( offs ) new_item: para_run nxtc: buf_offsets ?dup IF 2* \ 4 buf_start + >pos: buf_tmp count: buf_tmp get_para: self THEN ?do_para_override ?keep_para ;m :m (PARA_BLK_IN): \ ( cnt -- ) 2 nxtn: para_blk#s set_buf: self NIF next_offs drop ELSE 4 skip: buf THEN last: buf ( # paras ) dup 1+ 4* skip: buf_offsets 0 ?DO (para_in): self LOOP ;m :m PARAS_IN: true -> doing_paras? use: para_blk_str setup_blks -> #para_blks dst copyto: para_blk#s #para_blks 0 DO pause i (para_blk_in): self LOOP ;m :m STYLES_IN: \ Note: we ignore input style specifications, and just \ hang on to the names. pause use: styles_str2 2 nxtn: theFile -> #levels 2 nxtn: theFile 2- >len: theFile theFile ->: style_names ;m :m HFs_IN: use: sectoffs_str theFile ->: sect_offsets use: HFoffs_str mark_HFs ;m :m FTNOTES_IN: \ Footnotes in. Sorry for funny name - we had \ a hash collision. ftn_len 0EXIT \ Out if no footnotes use: ftn_marker_str theFile ->: ftn_markers use: ftn_offset_str theFile ->: ftn_offsets mark_ftn ;m :m SETUP_INPUT: pause new: theFile new: changes new: fmt_ov_str new: fmt_ov_run new: para_ov_str new: sect_offsets new: sect_ov_str new: ftn_markers new: ftn_offsets false -> mystery? 0 -> #insrtd 0 -> save_offs ^base 2+ hdr_len 2- read: theFcb OK? get: fast_save? $ 2000 and 0<> \ 4 -> fast? get: text_length -> real_text_len get: tx_end_offs hdr_len - -> text&HF_len \ get: page_options $ 8000 and 0<> -> facing_pages? \ 4 text&HF_len ++> mem_needed get: footnote_len -> ftn_len text_only? ?EXIT size: theFcb hdr_len - text&HF_len - 3 * 0 max \ Guesstimate for size of fmt_run etc. ++> mem_needed ;m :m INPUT_FILE: pause theFcb size: theFcb hdr_len - readn: theFile ;m :m FIXIT: setup_changes: self text_in: self text_only? NIF fmts_in: self paras_in: self styles_in: self ftnotes_in: self HFs_in: self THEN ;m :m WINDUP_INPUT: release: theFile release: changes release: fmt_ov_str release: fmt_ov_run release: para_ov_str release: sect_offsets release: sect_ov_str release: ftn_offsets release: ftn_markers ;m \ We are not including the output section as yet. ;class \ The exports - we can't export an object directly, only a colon defn. \ So this involves a bit of fooling around. MW3doc 3DOC MW4doc 4DOC : SETUP_INP3 setup_input: 3doc ; : SETUP_INP4 setup_input: 4doc ; : INPUT_FILE3 input_file: 3doc ; : INPUT_FILE4 input_file: 4doc ; : FIXIT3 fixit: 3doc ; : FIXIT4 fixit: 4doc ; : WINDUP_INP3 windup_input: 3doc ; : WINDUP_INP4 windup_input: 4doc ; : SEND3 send: 3doc ; : (STR_OUT) str_out: 3doc ;